home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
New Star Software Collection
/
NSS_Collection.iso
/
3-004 ms visual basic pro 30
/
4.imz
/
4.IMA
/
QUERY.FR_
/
QUERY.bin
Wrap
Text File
|
1993-04-28
|
18KB
|
666 lines
VERSION 2.00
Begin Form fQuery
BackColor = &H00C0C0C0&
BorderStyle = 1 'Fixed Single
Caption = "Query Builder"
ClientHeight = 5130
ClientLeft = 1230
ClientTop = 1155
ClientWidth = 7095
ControlBox = 0 'False
Height = 5535
Icon = QUERY.FRX:0000
KeyPreview = -1 'True
Left = 1170
LinkTopic = "Form1"
MaxButton = 0 'False
MDIChild = -1 'True
ScaleHeight = 5112
ScaleMode = 0 'User
ScaleWidth = 7116
Top = 810
Width = 7215
Begin PictureBox ExpressionBox
BackColor = &H00C0C0C0&
Height = 1092
Left = 120
ScaleHeight = 1065
ScaleWidth = 6825
TabIndex = 17
Tag = "OL"
Top = 120
Width = 6852
Begin CommandButton GetValuesButton
Caption = "List Possible &Values"
Height = 252
Left = 4200
TabIndex = 23
Top = 720
Width = 2292
End
Begin ComboBox cValue
BackColor = &H00FFFFFF&
Height = 288
Left = 4080
Sorted = -1 'True
TabIndex = 22
Text = "cValue"
Top = 360
Width = 2652
End
Begin ComboBox cOperator
BackColor = &H00FFFFFF&
Height = 288
Left = 2880
Style = 2 'Dropdown List
TabIndex = 21
Top = 360
Width = 1092
End
Begin ComboBox cField
BackColor = &H00FFFFFF&
Height = 288
Left = 120
Style = 2 'Dropdown List
TabIndex = 20
Top = 360
Width = 2652
End
Begin CommandButton ORButton
Caption = "&Or into Criteria"
Height = 252
Left = 2040
TabIndex = 19
Top = 720
Width = 1812
End
Begin CommandButton ANDButton
Caption = "&And into Criteria"
Height = 252
Left = 120
TabIndex = 18
Top = 720
Width = 1812
End
Begin Label OperatorLabel
BackColor = &H00C0C0C0&
Caption = "Operator:"
Height = 192
Left = 2880
TabIndex = 26
Top = 120
Width = 972
End
Begin Label ValueLabel
BackColor = &H00C0C0C0&
Caption = "Value:"
Height = 192
Left = 4080
TabIndex = 25
Top = 120
Width = 1452
End
Begin Label FieldNameLabel
BackColor = &H00C0C0C0&
Caption = "Field Name:"
Height = 192
Left = 120
TabIndex = 24
Top = 120
Width = 1332
End
End
Begin CommandButton JoinButton
Caption = "Set Table &Joins"
Height = 255
Left = 4440
TabIndex = 16
Top = 2520
Width = 2535
End
Begin ListBox cJoinFields
BackColor = &H00FFFFFF&
Height = 420
Left = 4440
TabIndex = 15
Tag = "OL"
Top = 2760
Width = 2535
End
Begin CommandButton CopySQLButton
Caption = "&Copy SQL"
Height = 375
Left = 3000
TabIndex = 14
Top = 4680
Width = 1095
End
Begin ComboBox cOrderByField
BackColor = &H00FFFFFF&
Height = 300
Left = 4440
Style = 2 'Dropdown List
TabIndex = 12
Tag = "OL"
Top = 2160
Width = 2535
End
Begin ComboBox cGroupByField
BackColor = &H00FFFFFF&
Height = 300
Left = 4440
Style = 2 'Dropdown List
TabIndex = 10
Tag = "OL"
Top = 1560
Width = 2535
End
Begin ListBox cTableList
BackColor = &H00FFFFFF&
Height = 1590
Left = 120
MultiSelect = 1 'Simple
TabIndex = 9
Tag = "OL"
Top = 1560
Width = 1575
End
Begin CommandButton ShowSQLButton
Caption = "&Show SQL"
Height = 375
Left = 1680
TabIndex = 8
Top = 4680
Width = 1095
End
Begin ListBox cShowFields
BackColor = &H00FFFFFF&
Height = 1590
Left = 1800
MultiSelect = 1 'Simple
TabIndex = 5
Tag = "OL"
Top = 1560
Width = 2535
End
Begin CommandButton CloseButton
Cancel = -1 'True
Caption = "Close"
Height = 375
Left = 5640
TabIndex = 2
Top = 4680
Width = 1095
End
Begin CommandButton RunQueryButton
Caption = "&Run Query"
Height = 375
Left = 360
TabIndex = 1
Top = 4680
Width = 1095
End
Begin CommandButton ClearButton
Caption = "C&lear All"
Height = 375
Left = 4320
TabIndex = 0
Top = 4680
Width = 1095
End
Begin TextBox cCriteria
BackColor = &H00FFFFFF&
Height = 1215
Left = 120
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 3
Tag = "OL"
Top = 3360
Width = 6855
End
Begin Label OrberByFieldLabel
BackColor = &H00C0C0C0&
Caption = "Order By Field:"
Height = 192
Left = 4440
TabIndex = 13
Top = 1920
Width = 2055
End
Begin Label GroupByFieldLabel
BackColor = &H00C0C0C0&
Caption = "Group By Field:"
Height = 192
Left = 4440
TabIndex = 11
Top = 1320
Width = 2055
End
Begin Label TableListLabel
BackColor = &H00C0C0C0&
Caption = "Select Tables:"
Height = 192
Left = 120
TabIndex = 7
Top = 1320
Width = 1455
End
Begin Label ShowFieldsLabel
BackColor = &H00C0C0C0&
Caption = "Select Fields to Show:"
Height = 192
Left = 1800
TabIndex = 6
Top = 1320
Width = 2055
End
Begin Label CriteriaLabel
BackColor = &H00C0C0C0&
Caption = "Criteria:"
Height = 180
Left = 120
TabIndex = 4
Top = 3150
Width = 1335
End
End
Dim FShowSQL As Integer
Dim FCopySQL As Integer
Sub ANDButton_Click ()
Dim f As Field
If cField = "" Then Exit Sub
Set f = gCurrentDB.TableDefs(stSTF((cField), 0)).Fields(stSTF((cField), 1))
If cCriteria <> "" Then
cCriteria = cCriteria + Chr(13) + Chr(10) + "And "
End If
If f.Type = FT_STRING Or f.Type = FT_MEMO Or f.Type = FT_DATETIME Then
cCriteria = cCriteria + cField + " " + cOperator + " '" + cValue + "'"
Else
cCriteria = cCriteria + cField + " " + cOperator + " " + cValue
End If
cField.SetFocus
End Sub
Sub cField_Click ()
cValue.Clear
End Sub
Sub ClearButton_Click ()
cCriteria = ""
End Sub
Sub CloseButton_Click ()
Unload Me
End Sub
Sub CopySQLButton_Click ()
FCopySQL = True
Call RunQueryButton_Click
FCopySQL = False
End Sub
Sub cTableList_Click ()
Dim i As Integer, ii As Integer
Dim t As TableDef
Dim st As String
MsgBar "Updating Form Fields", True
cField.Clear
cShowFields.Clear
cGroupByField.Clear
cOrderByField.Clear
cValue.Clear
cGroupByField.AddItem "(none)"
cOrderByField.AddItem "(none)"
For ii = 0 To cTableList.ListCount - 1
If cTableList.Selected(ii) Then
Set t = gCurrentDB.TableDefs(cTableList.List(ii))
For i = 0 To t.Fields.Count - 1
st = cTableList.List(ii) + "." + t.Fields(i).Name
cField.AddItem st
cShowFields.AddItem st
cGroupByField.AddItem st
cOrderByField.AddItem st
Next
End If
Next
If cField.List(0) <> "" Then
cField.ListIndex = 0
cGroupByField.ListIndex = 0
cOrderByField.ListIndex = 0
End If
MsgBar "", False
End Sub
Sub Form_Load ()
On Local Error GoTo FLErr
Dim ds As DynaSet
Dim i As Integer
Dim t As TableDef
'Clear listbox
cCriteria = ""
'Fill the Operator combo
cOperator.AddItem "="
cOperator.AddItem "<>"
cOperator.AddItem ">"
cOperator.AddItem ">="
cOperator.AddItem "<"
cOperator.AddItem "<="
cOperator.AddItem "Like"
cOperator.ListIndex = 0
'fill the table list
For i = 0 To fTables.cTableList.ListCount - 1
cTableList.AddItem fTables.cTableList.List(i)
Next
cTableList.ListIndex = 0
cValue = ""
GoTo FLEnd
FLErr:
ShowError
Resume FLEnd
FLEnd:
Height = 5520
Width = 7224
Left = (VDMDI.Width - Width) / 2
Top = 0
End Sub
Sub Form_Paint ()
Outlines Me
PicOutlines ExpressionBox, cField
PicOutlines ExpressionBox, cOperator
PicOutlines ExpressionBox, cValue
End Sub
Sub Form_Resize ()
On Error Resume Next
If WindowState <> 1 Then
Height = 5520
Width = 7224
End If
End Sub
Sub GetValuesButton_Click ()
Dim ds As DynaSet
On Error GoTo GVErr
MsgBar "Getting Possible Values", True
SetHourglass Me
Set ds = gCurrentDB.CreateDynaset("select Distinct " + (cField) + " from " + stSTF((cField), 0))
Do While ds.EOF = False
If Trim(ds(0)) <> "" Then
cValue.AddItem ds(0).Value
End If
ds.MoveNext
Loop
ds.Close
cValue = cValue.List(0)
cValue.SetFocus
GoTo GVEnd
GVErr:
cValue = ""
Resume GVEnd
GVEnd:
ResetMouse Me
MsgBar "", False
End Sub
Sub JoinButton_Click ()
Dim i As Integer
Dim c As Integer
For i = 0 To cTableList.ListCount - 1
If cTableList.Selected(i) = True Then
c = c + 1
End If
Next
If c < 2 Then
Beep
MsgBox "You Must Have at Least 2 Tables Selected!", 48
Else
MsgBar "Choose Joins", False
fJoin.Show MODAL
MsgBar "", False
End If
End Sub
Sub ORButton_Click ()
Dim f As Field
If cField = "" Then Exit Sub
Set f = gCurrentDB.TableDefs(stSTF((cField), 0)).Fields(stSTF((cField), 1))
If cCriteria <> "" Then
cCriteria = cCriteria + Chr(13) + Chr(10) + " Or "
End If
If f.Type = FT_STRING Or f.Type = FT_MEMO Or f.Type = FT_DATETIME Then
cCriteria = cCriteria + cField + " " + cOperator + " '" + cValue + "'"
Else
cCriteria = cCriteria + cField + " " + cOperator + " " + cValue
End If
cField.SetFocus
End Sub
Sub RunQueryButton_Click ()
On Error GoTo OKErr
Dim ds As DynaSet
Dim fs As String
Dim ts As String
Dim i As Integer
MsgBar "Building Query", True
If cCriteria <> "" Then
stWhere$ = "AND " + LTrim(cCriteria)
'strip CRLFs
For i = 1 To Len(stWhere$)
If Mid(stWhere$, i, 1) = Chr$(13) Then
stTmp$ = stTmp$ + " "
ElseIf Mid(stWhere$, i, 1) = Chr$(10) Then
'do nothing
Else
stTmp$ = stTmp$ + Mid(stWhere$, i, 1)
End If
Next
stWhere$ = stTmp$
stWhere$ = RTrim(stWhere$)
'Add parens to stWhere$
stTmpWhere$ = stWhere$
Do
stTmp$ = stGetToken(stTmpWhere$, " ")
If fMatchParen% = False And UCase(stTmp$) = "AND" Then
stNewWhere$ = stNewWhere$ + stTmp$ + " ("
fMatchParen% = True
ElseIf fMatchParen% = True And UCase(stTmp$) = "AND" Then
stNewWhere$ = stNewWhere$ + ") " + stTmp$ + " ("
'fMatchParen% = False
Else
If UCase(stTmp$) = "OR" Or UCase(stTmp$) = "IN" Or UCase(stTmp$) = "LIKE" Then
stNewWhere$ = stNewWhere$ + " " + stTmp$ + " "
Else
stNewWhere$ = stNewWhere$ + stTmp$
End If
End If
Loop Until stTmpWhere$ = ""
stWhere$ = stNewWhere$ + ")"
'Build DynaSet string:
'Peel off leading AND/OR
If Mid(stWhere$, 2, 2) = "OR" Then
stWhere$ = Mid(stWhere$, 5, Len(stWhere$) - 5)
Else
stTmp$ = stGetToken(stWhere$, " ")
End If
If stWhere$ <> "" Then
stWhere$ = " Where " + stWhere$
End If
End If
'check for join condition
If cJoinFields.ListCount > 0 Then
If stWhere$ = "" Then
stWhere$ = stWhere$ + " Where "
Else
stWhere$ = stWhere$ + " And "
End If
For i = 0 To cJoinFields.ListCount - 1
stWhere$ = stWhere$ + cJoinFields.List(i) + " And "
Next
stWhere$ = Mid(stWhere$, 1, Len(stWhere$) - 5)
End If
'check for group by field
If cGroupByField <> "(none)" Then
stWhere$ = stWhere$ + " Group By " + cGroupByField
End If
'check for order by field
If cOrderByField <> "(none)" Then
stWhere$ = stWhere$ + " Order By " + cOrderByField
End If
'get show field names
For i% = 0 To cShowFields.ListCount - 1
If cShowFields.Selected(i%) Then
fs = fs + cShowFields.List(i%) + ","
End If
Next
If fs = "" Then
For i% = 0 To cTableList.ListCount - 1
If cTableList.Selected(i%) Then
fs = fs + cTableList.List(i%) + ".*,"
End If
Next
If fs = "" Then
fs = "*"
Else
fs = Mid(fs, 1, Len(fs) - 1) 'take off the last ","
End If
Else
fs = Mid(fs, 1, Len(fs) - 1)
End If
'get table names
For i% = 0 To cTableList.ListCount - 1
If cTableList.Selected(i%) Then
ts = ts + cTableList.List(i%) + ","
End If
Next
ts = Mid(ts, 1, Len(ts) - 1)
gstDynaString = "Select " + fs + " From " + ts + stWhere$
If FShowSQL = False And FCopySQL = False Then
MsgBar "Running Query", True
gfFromSQL = True
'create a new dynaset form
If VDMDI.cSingleRecord = True Then
Dim dsform1 As New fDynaset
dsform1.Show
Else
Dim dsform2 As New fGridFrm
dsform2.Show
End If
ElseIf FShowSQL = True Then
MsgBar "", False
MsgBox gstDynaString, 0, "SQL Query"
ElseIf FCopySQL = True Then
fSQL.cSQLStatement = gstDynaString
End If
GoTo OKEnd
OKErr:
If Err = 364 Then Resume OKEnd 'catch unloaded form
ShowError
Resume OKEnd
OKEnd:
MsgBar "", False
End Sub
Sub ShowSQLButton_Click ()
FShowSQL = True
Call RunQueryButton_Click
FShowSQL = False
End Sub
Function stGetToken (stLn$, stDelim$) As String
On Error GoTo GetTokenError
iOpenQuote% = InStr(1, stLn$, """")
iDelim% = InStr(1, stLn$, stDelim$)
If (iOpenQuote% > 0) And (iOpenQuote% < iDelim%) Then
iCloseQuote% = InStr(iOpenQuote% + 1, stLn$, """")
iDelim% = InStr(iCloseQuote% + 1, stLn$, stDelim$)
End If
If (iDelim% <> 0) Then
stToken$ = LTrim$(RTrim$(Mid$(stLn$, 1, iDelim% - 1)))
stLn$ = Mid$(stLn$, iDelim% + 1)
Else
stToken$ = LTrim$(RTrim$(Mid$(stLn$, 1)))
stLn$ = ""
End If
If (Len(stToken$) > 0) Then
If (Mid$(stToken$, 1, 1) = """") Then
stToken$ = Mid$(stToken$, 2)
End If
If (Mid$(stToken$, Len(stToken$), 1) = """") Then
stToken$ = Mid$(stToken$, 1, Len(stToken$) - 1)
End If
End If
stGetToken = stToken$
GetTokenExit:
Exit Function
GetTokenError:
Resume GetTokenExit
End Function
'function to split the table and the field from a tbl.fld pair
Function stSTF (tf As String, part As Integer) As String
If part = 0 Then
stSTF = Mid(tf, 1, InStr(1, tf, ".") - 1)
Else
stSTF = Mid(tf, InStr(1, tf, ".") + 1, Len(tf))
End If
End Function